home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / ti / pcscm3_3 / pkdisk2.arc / HELP.S < prev    next >
Encoding:
Text File  |  1988-06-07  |  5.9 KB  |  206 lines
  1. ;;;;          APPENDIX: HELP SYSTEM SOURCE CODE
  2.  
  3. ;;;;
  4. ;;;;    A Help facility for PC Scheme
  5. ;;;;
  6. ;;;;    Precis of instructions:
  7. ;;;;      1. Load this file, i.e., type (load "help.s")
  8. ;;;;      2. To extract information on the definitions
  9. ;;;;         in a file of Scheme source code, type
  10. ;;;;         (extract-help "filename").
  11. ;;;;      3. To extract the help information and
  12. ;;;;         at the same time load the file, type
  13. ;;;;         (load-with-help "filename").
  14. ;;;;      4. Type (help 'ident) for information on the
  15. ;;;;         name ident.
  16. ;;;;      5. Type (help), without arguments, for a list
  17. ;;;;         of all identifiers for which extended
  18. ;;;;         help is available.
  19.  
  20. (define help
  21.   (lambda subject
  22.     (if (null? subject)
  23.         (show-help-topics)
  24.         (fetch-help (car subject)))
  25.     *the-non-printing-object*))
  26.  
  27.  
  28. (define fetch-help
  29.   (lambda (item)
  30.     (report-help item
  31.                  (get-internal-help item)
  32.                  (get-archival-help item))))
  33.  
  34. (define get-internal-help
  35.   (lambda (item)
  36.     (let ((item-class (classify item)))
  37.       (if (and (symbol? item) (bound? item))
  38.           (let* ((value       (eval item))
  39.                  (value-class (classify value)))
  40.             (list item-class value value-class))
  41.           (list item-class)))))
  42.  
  43.  
  44. (define classify
  45.   (lambda (x)
  46.     (cond ((pair?        x) 'pair)
  47.           ((procedure?   x) (cond ((closure?      x) 'procedure)
  48.                                   ((continuation? x) 'continuation)
  49.                                   (else              'engine)))
  50.           ((boolean?     x) 'boolean)
  51.           ((symbol?      x) 'symbol)
  52.           ((environment? x) 'environment)
  53.           ((stream?      x) 'stream)
  54.           ((port?        x) 'port)
  55.           ((number?      x) 'number)
  56.           ((char?        x) 'character)
  57.           ((string?      x) 'string)
  58.           ((vector?      x) 'vector)
  59.           (else             'unknown))))
  60.  
  61.  
  62. (define bound?
  63.   (lambda (ident)
  64.     (not (eval `(unbound? ,ident)))))
  65.  
  66.  
  67. (define archive
  68.   (let ((a-list '() ))
  69.     (lambda (msg . args)
  70.       (case msg
  71.         ((get)     (cadr (assq (car args) a-list)))
  72.         ((put)     (archive 'remove (car args))
  73.                    (set! a-list (cons args a-list)))
  74.         ((keys)    (map car a-list))
  75.         ((remove)  (set! a-list (delq! (assq (car args) a-list) a-list)))
  76.         (else      (error "Unrecognized message to archive:" msg))))))
  77.  
  78.  
  79. (define get-archival-help
  80.   (lambda (item)
  81.     (archive 'get item)))
  82.  
  83.  
  84. (define show-help-topics
  85.   (lambda ()
  86.     (writeln "Topics for which extended help is available:")
  87.     (for-each writeln (archive 'keys))))
  88.  
  89.  
  90. (define extract-help
  91.   (lambda (filename)
  92.     (with-input-from-file filename
  93.       (lambda ()
  94.         (do ((next (read) (read)))
  95.             ((eof-object? next) 'OK)
  96.             (let ((info (parse next)))
  97.               (when info (put-archival-help filename info))))))))
  98.  
  99.  
  100. (define parse
  101.   (lambda (expr)
  102.     (if (and (pair? expr) (eq? (car expr) 'define))
  103.         (if (pair? (cadr expr))
  104.             (parse-mit (cadr expr))
  105.             (parse-iu (cdr expr)))
  106.         '() )))
  107.  
  108.  
  109. (define parse-mit
  110.   (lambda (expr)
  111.     (if (pair? (car expr))
  112.         (parse-mit (car expr))
  113.         (parse-params (car expr) (cdr expr)))))
  114.  
  115.  
  116. (define parse-iu
  117.   (lambda (expr)
  118.     (let ((lambda-form (get-lambda (cadr expr))))
  119.       (if lambda-form
  120.           (parse-params (car expr) (cadr lambda-form))
  121.           '() ))))
  122.  
  123.  
  124. (define get-lambda
  125.   (lambda (e)
  126.     (if (or (null? e) (atom? e))
  127.         '()
  128.         (case (car e)
  129.           ((lambda) e)
  130.           ((let let* letrec) (get-lambda (car (last-pair e))))
  131.           (else '() )))))
  132.  
  133.  
  134. (define parse-params
  135.   (lambda (name paramlist)
  136.     (let loop ((params paramlist) (count 0))
  137.       (cond ((null? params) (list name count 0 paramlist))
  138.             ((atom? params) (list name count 1 paramlist))
  139.             (else (loop (cdr params) (+ 1 count)))))))
  140.  
  141.  
  142. (define put-archival-help
  143.   (lambda (filename info)
  144.     (archive 'put (car info) (append (list filename)
  145.                                      (cdr info)))))
  146.  
  147.  
  148. (define load-with-help
  149.   (lambda (filename)
  150.     (extract-help filename)
  151.     (load filename)))
  152.  
  153.  
  154. (define report-help
  155.   (lambda (item internal-info archival-info)
  156.     (let ((item-class  (car   internal-info))
  157.           (value       (cadr  internal-info))
  158.           (value-class (caddr internal-info)))
  159.       (newline)
  160.       (cond ((not (symbol? item)) (report-literal item item-class))
  161.             ((null? value-class)  (report-unbound item))
  162.             (else                 (report-binding item value value-class)))
  163.       (when archival-info (report-archival item archival-info)))))
  164.  
  165.  
  166. (define report-literal
  167.   (lambda (item class)
  168.     (writeln item " is an object of type " class ".")
  169.     (newline)))
  170.  
  171.  
  172. (define report-unbound
  173.   (lambda (item)
  174.     (writeln "The identifier " item " is unbound.")
  175.     (newline)))
  176.  
  177.  
  178. (define report-binding
  179.   (lambda (item value class)
  180.     (writeln "The identifier " item
  181.              " is bound to an object of type " class ".")
  182.     (when (denotable? class)
  183.           (writeln "The value of " item " is " value "."))
  184.     (newline)))
  185. (define denotable?
  186.   (lambda (class)
  187.     (memq class '(boolean number character string vector pair symbol))))
  188.  
  189.  
  190. (define report-archival
  191.   (lambda (item info)
  192.     (let* ((filename (car    info))
  193.            (req-args (cadr   info))
  194.            (opt-args (caddr  info))
  195.            (params   (cadddr info))
  196.            (argstr   (if (= 1 req-args) "argument" "arguments"))
  197.            (optstr   (if (zero? opt-args) "no" "any number of")))
  198.       (writeln item " is defined in file " filename)
  199.       (writeln "as a procedure of " req-args " required " argstr)
  200.       (writeln "and " optstr " optional arguments.")
  201.       (writeln "The parameters to " item " are declared as follows:")
  202.       (writeln params)
  203.       (newline))))
  204.  
  205.  
  206.